home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / nt / emacssrc.zip / EMACSSRC.TAR / emacs-19.17 / lisp / nnspool.el < prev    next >
Lisp/Scheme  |  1993-07-23  |  13KB  |  410 lines
  1. ;;; nnspool.el --- spool access using NNTP for GNU Emacs
  2.  
  3. ;; Copyright (C) 1988, 1989, 1990, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to
  22. ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23.  
  24. ;;; Code:
  25.  
  26. (require 'nntp)
  27.  
  28. (defvar nnspool-inews-program news-inews-program
  29.   "*Program to post news.")
  30.  
  31. (defvar nnspool-inews-switches '("-h")
  32.   "*Switches for nnspool-request-post to pass to `inews' for posting news.")
  33.  
  34. (defvar nnspool-spool-directory news-path
  35.   "*Local news spool directory.")
  36.  
  37. (defvar nnspool-active-file "/usr/lib/news/active"
  38.   "*Local news active file.")
  39.  
  40. (defvar nnspool-newsgroups-file "/usr/lib/news/newsgroups"
  41.   "*Local news newsgroups file.")
  42.  
  43. (defvar nnspool-distributions-file "/usr/lib/news/distributions"
  44.   "*Local news distributions file.")
  45.  
  46. (defvar nnspool-history-file "/usr/lib/news/history"
  47.   "*Local news history file.")
  48.  
  49.  
  50.  
  51. (defconst nnspool-version "NNSPOOL 1.12"
  52.   "Version numbers of this version of NNSPOOL.")
  53.  
  54. (defvar nnspool-current-directory nil
  55.   "Current news group directory.")
  56.  
  57. ;;;
  58. ;;; Replacement of Extended Command for retrieving many headers.
  59. ;;;
  60.  
  61. (defun nnspool-retrieve-headers (sequence)
  62.   "Return list of article headers specified by SEQUENCE of article id.
  63. The format of list is
  64.  `([NUMBER SUBJECT FROM XREF LINES DATE MESSAGE-ID REFERENCES] ...)'.
  65. If there is no References: field, In-Reply-To: field is used instead.
  66. Reader macros for the vector are defined as `nntp-header-FIELD'.
  67. Writer macros for the vector are defined as `nntp-set-header-FIELD'.
  68. Newsgroup must be selected before calling this."
  69.   (save-excursion
  70.     (set-buffer nntp-server-buffer)
  71.     ;;(erase-buffer)
  72.     (let ((file nil)
  73.       (number (length sequence))
  74.       (count 0)
  75.       (headers nil)            ;Result list.
  76.       (article 0)
  77.       (subject nil)
  78.       (message-id nil)
  79.       (from nil)
  80.       (xref nil)
  81.       (lines 0)
  82.       (date nil)
  83.       (references nil))
  84.       (while sequence
  85.     ;;(nntp-send-strings-to-server "HEAD" (car sequence))
  86.     (setq article (car sequence))
  87.     (setq file
  88.           (concat nnspool-current-directory (prin1-to-string article)))
  89.     (if (and (file-exists-p file)
  90.          (not (file-directory-p file)))
  91.         (progn
  92.           (erase-buffer)
  93.           (insert-file-contents file)
  94.           ;; Make message body invisible.
  95.           (goto-char (point-min))
  96.           (search-forward "\n\n" nil 'move)
  97.           (narrow-to-region (point-min) (point))
  98.           ;; Fold continuation lines.
  99.           (goto-char (point-min))
  100.           (while (re-search-forward "\\(\r?\n[ \t]+\\)+" nil t)
  101.         (replace-match " " t t))
  102.           ;; Make it possible to search for `\nFIELD'.
  103.           (goto-char (point-min))
  104.           (insert "\n")
  105.           ;; Extract From:
  106.           (goto-char (point-min))
  107.           (if (search-forward "\nFrom: " nil t)
  108.           (setq from (buffer-substring
  109.                   (point)
  110.                   (save-excursion (end-of-line) (point))))
  111.         (setq from "(Unknown User)"))
  112.           ;; Extract Subject:
  113.           (goto-char (point-min))
  114.           (if (search-forward "\nSubject: " nil t)
  115.           (setq subject (buffer-substring
  116.                  (point)
  117.                  (save-excursion (end-of-line) (point))))
  118.         (setq subject "(None)"))
  119.           ;; Extract Message-ID:
  120.           (goto-char (point-min))
  121.           (if (search-forward "\nMessage-ID: " nil t)
  122.           (setq message-id (buffer-substring
  123.                     (point)
  124.                     (save-excursion (end-of-line) (point))))
  125.         (setq message-id nil))
  126.           ;; Extract Date:
  127.           (goto-char (point-min))
  128.           (if (search-forward "\nDate: " nil t)
  129.           (setq date (buffer-substring
  130.                   (point)
  131.                   (save-excursion (end-of-line) (point))))
  132.         (setq date nil))
  133.           ;; Extract Lines:
  134.           (goto-char (point-min))
  135.           (if (search-forward "\nLines: " nil t)
  136.           (setq lines (string-to-int
  137.                    (buffer-substring
  138.                 (point)
  139.                 (save-excursion (end-of-line) (point)))))
  140.         (setq lines 0))
  141.           ;; Extract Xref:
  142.           (goto-char (point-min))
  143.           (if (search-forward "\nXref: " nil t)
  144.           (setq xref (buffer-substring
  145.                   (point)
  146.                   (save-excursion (end-of-line) (point))))
  147.         (setq xref nil))
  148.           ;; Extract References:
  149.           ;; If no References: field, use In-Reply-To: field instead.
  150.           (goto-char (point-min))
  151.           (if (or (search-forward "\nReferences: " nil t)
  152.               (search-forward "\nIn-Reply-To: " nil t))
  153.           (setq references (buffer-substring
  154.                     (point)
  155.                     (save-excursion (end-of-line) (point))))
  156.         (setq references nil))
  157.           ;; Collect valid article only.
  158.           (and article
  159.            message-id
  160.            (setq headers
  161.              (cons (vector article subject from
  162.                        xref lines date
  163.                        message-id references) headers)))
  164.           ))
  165.     (setq sequence (cdr sequence))
  166.     (setq count (1+ count))
  167.     (and (numberp nntp-large-newsgroup)
  168.          (> number nntp-large-newsgroup)
  169.          (zerop (% count 20))
  170.          (message "NNSPOOL: Receiving headers... %d%%"
  171.               (/ (* count 100) number)))
  172.     )
  173.       (and (numberp nntp-large-newsgroup)
  174.        (> number nntp-large-newsgroup)
  175.        (message "NNSPOOL: Receiving headers... done"))
  176.       (nreverse headers)
  177.       )))
  178.  
  179.  
  180. ;;;
  181. ;;; Replacement of NNTP Raw Interface.
  182. ;;;
  183.  
  184. (defun nnspool-open-server (host &optional service)
  185.   "Open news server on HOST.
  186. If HOST is nil, use value of environment variable `NNTPSERVER'.
  187. If optional argument SERVICE is non-nil, open by the service name."
  188.   (let ((host (or host (getenv "NNTPSERVER")))
  189.     (status nil))
  190.     (setq nntp-status-string "")
  191.     (cond ((and (file-directory-p nnspool-spool-directory)
  192.         (file-exists-p nnspool-active-file)
  193.         (string-equal host (system-name)))
  194.        (setq status (nnspool-open-server-internal host service)))
  195.       ((string-equal host (system-name))
  196.        (setq nntp-status-string
  197.          (format "%s has no news spool.  Goodbye." host)))
  198.       ((null host)
  199.        (setq nntp-status-string "NNTP server is not specified."))
  200.       (t
  201.        (setq nntp-status-string
  202.          (format "NNSPOOL: cannot talk to %s." host)))
  203.       )
  204.     status
  205.     ))
  206.  
  207. (defun nnspool-close-server ()
  208.   "Close news server."
  209.   (nnspool-close-server-internal))
  210.  
  211. (fset 'nnspool-request-quit (symbol-function 'nnspool-close-server))
  212.  
  213. (defun nnspool-server-opened ()
  214.   "Return server process status, T or NIL.
  215. If the stream is opened, return T, otherwise return NIL."
  216.   (and nntp-server-buffer
  217.        (get-buffer nntp-server-buffer)))
  218.  
  219. (defun nnspool-status-message ()
  220.   "Return server status response as string."
  221.   nntp-status-string
  222.   )
  223.  
  224. (defun nnspool-request-article (id)
  225.   "Select article by message ID (or number)."
  226.   (let ((file (if (stringp id)
  227.           (nnspool-find-article-by-message-id id)
  228.         (concat nnspool-current-directory (prin1-to-string id)))))
  229.     (if (and (stringp file)
  230.          (file-exists-p file)
  231.          (not (file-directory-p file)))
  232.     (save-excursion
  233.       (nnspool-find-file file)))
  234.     ))
  235.  
  236. (defun nnspool-request-body (id)
  237.   "Select article body by message ID (or number)."
  238.   (if (nnspool-request-article id)
  239.       (save-excursion
  240.     (set-buffer nntp-server-buffer)
  241.     (goto-char (point-min))
  242.     (if (search-forward "\n\n" nil t)
  243.         (delete-region (point-min) (point)))
  244.     t
  245.     )
  246.     ))
  247.  
  248. (defun nnspool-request-head (id)
  249.   "Select article head by message ID (or number)."
  250.   (if (nnspool-request-article id)
  251.       (save-excursion
  252.     (set-buffer nntp-server-buffer)
  253.     (goto-char (point-min))
  254.     (if (search-forward "\n\n" nil t)
  255.         (delete-region (1- (point)) (point-max)))
  256.     t
  257.     )
  258.     ))
  259.  
  260. (defun nnspool-request-stat (id)
  261.   "Select article by message ID (or number)."
  262.   (setq nntp-status-string "NNSPOOL: STAT is not implemented.")
  263.   nil
  264.   )
  265.  
  266. (defun nnspool-request-group (group)
  267.   "Select news GROUP."
  268.   (let ((pathname (nnspool-article-pathname
  269.            (nnspool-replace-chars-in-string group ?. ?/))))
  270.     (if (file-directory-p pathname)
  271.     (setq nnspool-current-directory pathname))
  272.     ))
  273.  
  274. (defun nnspool-request-list ()
  275.   "List active newsgoups."
  276.   (save-excursion
  277.     (nnspool-find-file nnspool-active-file)))
  278.  
  279. (defun nnspool-request-list-newsgroups ()
  280.   "List newsgroups (defined in NNTP2)."
  281.   (save-excursion
  282.     (nnspool-find-file nnspool-newsgroups-file)))
  283.  
  284. (defun nnspool-request-list-distributions ()
  285.   "List distributions (defined in NNTP2)."
  286.   (save-excursion
  287.     (nnspool-find-file nnspool-distributions-file)))
  288.  
  289. (defun nnspool-request-last ()
  290.   "Set current article pointer to the previous article
  291. in the current news group."
  292.   (setq nntp-status-string "NNSPOOL: LAST is not implemented.")
  293.   nil
  294.   )
  295.  
  296. (defun nnspool-request-next ()
  297.   "Advance current article pointer."
  298.   (setq nntp-status-string "NNSPOOL: NEXT is not implemented.")
  299.   nil
  300.   )
  301.  
  302. (defun nnspool-request-post ()
  303.   "Post a new news in current buffer."
  304.   (save-excursion
  305.     ;; We have to work in the server buffer because of NEmacs hack.
  306.     (copy-to-buffer nntp-server-buffer (point-min) (point-max))
  307.     (set-buffer nntp-server-buffer)
  308.     (apply (function call-process-region)
  309.        (point-min) (point-max)
  310.        nnspool-inews-program 'delete t nil nnspool-inews-switches)
  311.     (prog1
  312.     (or (zerop (buffer-size))
  313.         ;; If inews returns strings, it must be error message 
  314.         ;;  unless SPOOLNEWS is defined.  
  315.         ;; This condition is very weak, but there is no good rule 
  316.         ;;  identifying errors when SPOOLNEWS is defined.  
  317.         ;; Suggested by ohm@kaba.junet.
  318.         (string-match "spooled" (buffer-string)))
  319.       ;; Make status message by unfolding lines.
  320.       (subst-char-in-region (point-min) (point-max) ?\n ?\\ 'noundo)
  321.       (setq nntp-status-string (buffer-string))
  322.       (erase-buffer))
  323.     ))
  324.  
  325.  
  326. ;;;
  327. ;;; Replacement of Low-Level Interface to NNTP Server.
  328. ;;; 
  329.  
  330. (defun nnspool-open-server-internal (host &optional service)
  331.   "Open connection to news server on HOST by SERVICE (default is nntp)."
  332.   (save-excursion
  333.     (if (not (string-equal host (system-name)))
  334.     (error "NNSPOOL: cannot talk to %s." host))
  335.     ;; Initialize communication buffer.
  336.     (setq nntp-server-buffer (get-buffer-create " *nntpd*"))
  337.     (set-buffer nntp-server-buffer)
  338.     (buffer-flush-undo (current-buffer))
  339.     (erase-buffer)
  340.     (kill-all-local-variables)
  341.     (setq case-fold-search t)        ;Should ignore case.
  342.     (setq nntp-server-process nil)
  343.     (setq nntp-server-name host)
  344.     ;; It is possible to change kanji-fileio-code in this hook.
  345.     (run-hooks 'nntp-server-hook)
  346.     t
  347.     ))
  348.  
  349. (defun nnspool-close-server-internal ()
  350.   "Close connection to news server."
  351.   (if (get-file-buffer nnspool-history-file)
  352.       (kill-buffer (get-file-buffer nnspool-history-file)))
  353.   (if nntp-server-buffer
  354.       (kill-buffer nntp-server-buffer))
  355.   (setq nntp-server-buffer nil)
  356.   (setq nntp-server-process nil))
  357.  
  358. (defun nnspool-find-article-by-message-id (id)
  359.   "Return full pathname of an article identified by message-ID."
  360.   (save-excursion
  361.     (let ((buffer (get-file-buffer nnspool-history-file)))
  362.       (if buffer
  363.       (set-buffer buffer)
  364.     ;; Finding history file may take lots of time.
  365.     (message "Reading history file...")
  366.     (set-buffer (find-file-noselect nnspool-history-file))
  367.     (message "Reading history file... done")))
  368.     ;; Search from end of the file. I think this is much faster than
  369.     ;; do from the beginning of the file.
  370.     (goto-char (point-max))
  371.     (if (re-search-backward
  372.      (concat "^" (regexp-quote id)
  373.          "[ \t].*[ \t]\\([^ \t/]+\\)/\\([0-9]+\\)[ \t]*$") nil t)
  374.     (let ((group (buffer-substring (match-beginning 1) (match-end 1)))
  375.           (number (buffer-substring (match-beginning 2) (match-end 2))))
  376.       (concat (nnspool-article-pathname
  377.            (nnspool-replace-chars-in-string group ?. ?/))
  378.           number))
  379.       )))
  380.  
  381. (defun nnspool-find-file (file)
  382.   "Insert FILE in server buffer safely."
  383.   (set-buffer nntp-server-buffer)
  384.   (erase-buffer)
  385.   (condition-case ()
  386.       (progn (insert-file-contents file) t)
  387.     (file-error nil)
  388.     ))
  389.  
  390. (defun nnspool-article-pathname (group)
  391.   "Make pathname for GROUP."
  392.   (concat (file-name-as-directory nnspool-spool-directory) group "/"))
  393.  
  394. (defun nnspool-replace-chars-in-string (string from to)
  395.   "Replace characters in STRING from FROM to TO."
  396.   (let ((string (substring string 0))    ;Copy string.
  397.     (len (length string))
  398.     (idx 0))
  399.     ;; Replace all occurrences of FROM with TO.
  400.     (while (< idx len)
  401.       (if (= (aref string idx) from)
  402.       (aset string idx to))
  403.       (setq idx (1+ idx)))
  404.     string
  405.     ))
  406.  
  407. (provide 'nnspool)
  408.  
  409. ;;; nnspool.el ends here
  410.